(SETQ IBASE (ADD1 7)) 


(DEFPROP ALLFNS 
 (NIL T
      BETWX
      SAMEFACE
      TRUNCATE
      BAZ
      TRUNC
      BN
      VB
      FN
      EN
      QUIET
      DISPLAYFLAG
      MARK
      TYPE/.
      CLRGEM
      SAVE
      GEOINIT
      FOO
      DEBUGFLAG
      WAIT
      FATAL
      TJOINT
      K1
      G
      FOLDED
      VISIBLE
      POTENT
      JOTBIT
      JUTBIT
      EBIT
      BBIT
      DETSEG
      SHOW9
      *TEST
      EXCH
      SEENOD
      TYPE
      COPYPOS
      GARG) 
VALUE)

(DEFPROP T 
 (LAMBDA NIL (TRUNCATE (GARG 1))) 
EXPR)

(DEFPROP T 
 (NIL . T) 
VALUE)

(DEFPROP BETWX 
 (LAMBDA(VNEW V1 V2 K)
  (PROG (K1)
	(SETQ K1 (*DIF 1 K))
	(RETURN
	 (LIST (XWC/. VNEW (*PLUS (*TIMES (XWC V1) K) (*TIMES (XWC V2) K1)))
	       (YWC/. VNEW (*PLUS (*TIMES (YWC V1) K) (*TIMES (YWC V2) K1)))
	       (ZWC/. VNEW (*PLUS (*TIMES (ZWC V1) K) (*TIMES (ZWC V2) K1))))))) 
EXPR)

(DEFPROP SAMEFACE 
 (LAMBDA(E1 E2)
  (COND ((EQUAL (PFACE E1) (PFACE E2)) (PFACE E1))
	((EQUAL (PFACE E1) (NFACE E2)) (PFACE E1))
	((EQUAL (NFACE E1) (NFACE E2)) (NFACE E1))
	((EQUAL (NFACE E1) (PFACE E2)) (NFACE E1))
	(T (ERROR (QUOTE (No common face 0 SAMEFACE)))))) 
EXPR)

(DEFPROP TRUNCATE 
 (LAMBDA(B)
  (PROG (V1 V2 VN E0 E1 E2)
	(SETQ VN (NVT B))
	(SETQ E0 (NED B))
   LOOP1
	(SETQ V1 (PVT E0))
	(SETQ V2 (NVT E0))
	(BETWX (SETQ E1 (ESPLIT E0)) V2 V1 DDEL)
	(COND ((EQUAL DDEL 0.5) NIL) (T (BETWX (ESPLIT E0) V1 V2 DDEL)))
	(COND ((EQUAL (SETQ E0 (NED E0)) B) NIL) (T (GO LOOP1)))
	(SETQ V1 VN)
   LOOP2
	(SETQ E1 (PED V1))
	(SETQ V2 (OTHER E1 V1))
   LOOP3
	(SETQ E2 (ECCW E1 V1))
	(MKFE V2 (SAMEFACE E1 E2) (SETQ V2 (OTHER E2 V1)))
	(COND ((NOT (EQUAL (SETQ E1 E2) (PED V1))) (GO LOOP3))
	      ((NOT (EQUAL (SETQ V1 (NVT V1)) B)) (GO LOOP2))
	      (T NIL))
	(SETQ V1 VN)
   LOOP4
	(SETQ V2 (NVT V1))
	(KLFE (KLEV V1))
	(COND ((EQUAL (SETQ V1 V2) B) NIL) (T (GO LOOP4)))
	(GEODPY))) 
EXPR)

(DEFPROP BAZ 
 (LAMBDA(B)
  (PROG (V)
	(SETQ V (NVT B))
   LOOP (GPUSH V)
	(SETQ V (NVT V))
	(TRUNC (GPOP))
	(GPOP)
	(COND ((EQUAL V B) (GEODPY)) (T (GO LOOP))))) 
EXPR)

(DEFPROP TRUNC 
 (LAMBDA(V)
  (PROG (E0 E1 V0)
	(SETQ E0 (SETQ E1 (PED V)))
	(GPUSH 0)
   LOOP (GPUSH E1)
	(SETQ E1 (ECCW E1 V))
	(MIDPOINT)
	(COND (V0 NIL) (T (SETQ V0 (GARG 1))))
	(COND ((EQUAL E0 E1) NIL) (T (GO LOOP)))
	(GPUSH V0)
   LOOP2
	(COND ((EQ (GARG 2) 0) (PROG2 (GPOP) (GPOP) (GPUSH (KLEV V))))
	      (T (PROG2 (GPUSH (GARG 2)) (JOINVV) (GPOP) (GO LOOP2)))))) 
EXPR)

(DEFPROP BN 
 (LAMBDA(N)
  (PROG (B)
	(SETQ B WORLD)
   LOOP (SETQ B (CCW B))
	(COND ((*GREAT (SETQ N (SUB1 N)) 0) (GO LOOP)) (T (RETURN B))))) 
EXPR)

(DEFPROP FN 
 (LAMBDA(B N)
  (PROG NIL LOOP (SETQ B (PFACE B)) (COND ((*GREAT (SETQ N (SUB1 N)) 0) (GO LOOP)) (T (RETURN B))))) 
EXPR)

(DEFPROP EN 
 (LAMBDA (B N) (PROG NIL LOOP (SETQ B (PED B)) (COND ((*GREAT (SETQ N (SUB1 N)) 0) (GO LOOP)) (T (RETURN B))))) 
EXPR)

(DEFPROP QUIET 
 (LAMBDA(L)
  (PROG (DISPLAYFLAG DEBUGFLAG) (SETQ DEBUGFLAG NIL) (SETQ DISPLAYFLAG NIL) (MAPC (FUNCTION EVAL) L))) 
FEXPR)

(DEFPROP DISPLAYFLAG 
 (NIL) 
VALUE)

(DEFPROP MARK 
 (LAMBDA (V) (TYPE/. V (BOOLE 7 (TYPE V)))) 
EXPR)

(DEFPROP TYPE/. 
 (LAMBDA (N V) (ZWC/. (ADD1 N) V)) 
EXPR)

(DEFPROP CLRGEM 
 (LAMBDA NIL (UNTIL (EQ WORLD (CCW WORLD)) (KLB (CCW WORLD)))) 
EXPR)

(DEFPROP SAVE 
 (LAMBDA (L) (EVAL (LIST (QUOTE DSKOUT) (CAR L) (QUOTE (PROG2 (GRINL ALLFNS) (PRINT (QUOTE (GEOINIT)))))))) 
FEXPR)

(DEFPROP GEOINIT 
 (LAMBDA NIL (PROG2 START (DEPOSIT 124 (MAKNUM (GETQ START VALUE) (QUOTE FIXNUM))) (GEONIT) (DETSEG))) 
EXPR)

(DEFPROP FOO 
 (LAMBDA(L)
  (PROG NIL
	(MAPC (FUNCTION (LAMBDA (L) (GPUSH (EVAL L)))) L)
	(STADPY)
	(MAPC (FUNCTION (LAMBDA (L) (GPOP L))) L))) 
FEXPR)

(DEFPROP DEBUGFLAG 
 (NIL) 
VALUE)

(DEFPROP WAIT 
 (LAMBDA(L)
  (COND (DEBUGFLAG
	 (PROG (TMP TMP2)
	       (SETQ TMP (DDTIN T))
	       (SETQ TMP2 (TYI))
	       (DDTIN TMP)
	       (COND ((EQ TMP2 104) (PROG2 (PRINL L) (BREAK (WAIT)) (TYI))) (T NIL))))
	(T NIL))) 
FEXPR)

(DEFPROP FATAL 
 (LAMBDA (L) (PROG2 NIL (PRINL L) (BREAK (FATAL)) (FIX T))) 
FEXPR)

(DEFPROP TJOINT 
 (LAMBDA (N) (NED N)) 
EXPR)

(DEFPROP K1 
 (NIL . 0.5) 
VALUE)

(DEFPROP G 
 (LAMBDA NIL (PROG2 (COND ((EQ WORLD 0) (GEOINIT)) (T NIL)) (GEOMED))) 
EXPR)

(DEFPROP FOLDED 
 (NIL . 100000000) 
VALUE)

(DEFPROP VISIBLE 
 (NIL . 40000000) 
VALUE)

(DEFPROP POTENT 
 (NIL . 20000000) 
VALUE)

(DEFPROP JOTBIT 
 (NIL . 20000000000) 
VALUE)

(DEFPROP JUTBIT 
 (NIL . 40000000000) 
VALUE)

(DEFPROP EBIT 
 (NIL . 4000000) 
VALUE)

(DEFPROP BBIT 
 (NIL . 1000000) 
VALUE)

(DEFPROP DETSEG 
 (LAMBDA NIL (UUO 400017)) 
EXPR)

(DEFPROP SHOW9 
 (LAMBDA(POG)
  (PROG NIL (PPROJ CAMERA WORLD) (FMRK WORLD) (EMRK WORLD) (OCCULT WORLD) (CLIPER WINDOW) (IIIDPY WINDOW POG))) 
EXPR)

(DEFPROP *TEST 
 (LAMBDA NIL
  (PROG (E1 E2)
	(SETQ E1 (PED IMAGE))
   LOOP (PROG2 (GPUSH (ALT E1)) (STADPY) (GPOP))
	(COND ((EQUAL E1 (SETQ E2 (ALT (ALT E1)))) NIL)
	      ((NULL (TEST E1 EBIT)) (FATAL E1 NOT AN EDGE))
	      ((NULL (TEST E2 EBIT)) (FATAL E2 NOT AN EDGE))
	      (T (PROG NIL (GLUETILE E2 E1) (ALT/. (ALT E1) E1))))
	(COND ((EQUAL (SETQ E1 (PED E1)) IMAGE) (RETURN)) (T (GO LOOP))))) 
EXPR)

(DEFPROP EXCH 
 (LAMBDA (L) (PROG (TMP) (SETQ TMP (EVAL (CAR L))) (SET (CAR L) (EVAL (CADR L))) (SET (CADR L) TMP))) 
FEXPR)

(DEFPROP SEENOD 
 (LAMBDA (L) (PROG NIL (GPUSH L) (GEODPY) (STADPY) (GPOP))) 
EXPR)

(DEFPROP TYPE 
 (LAMBDA (N) (ZWC (ADD1 N))) 
EXPR)

(DEFPROP COPYPOS 
 (LAMBDA(VNEW VOLD)
  (PROG NIL
	(ZWC/. VNEW 0)
	(XWC/. VNEW (*TIMES K1 (XDC VOLD)))
	(YWC/. VNEW (*TIMES K1 (YDC VOLD)))
	(XDC/. VNEW (XDC VOLD))
	(YDC/. VNEW (YDC VOLD)))) 
EXPR)

(DEFPROP GARG 
 (LAMBDA (N) (EXAMINE (*DIF (BOOLE 1 PDLPTR 777777) (SUB1 N)))) 
EXPR)

(GEOINIT)